John B. Matthews, M.D.
Return home.
Download a
compressed, Apple II disk image of the Zap source code.
Zap: a disk and memory editor for Apple UCSD Pascal.
Here's the
source code for a disk and memory editor I wrote for Apple's UCSD Pascal bask in
1984. I cleaned up the code, squashed a few bugs and added several conveniences.
I also coded the inner loop of the hex conversion is assembler, making it some
50% faster. I was especially pleased with how easy it was to mix assembly with
Pascal in the UCSD nvironment. In contrast, Apple's relocating loader for ProDOS
was slow and cumbersome. Later ProDOS compilers, including Kyan and Orca, were a
substantial improvement.
If you build the code yourself, you'll have to
compile the source (using the system's Compile command) and link the assembly
code (using the system's Link command). I use Zap under Apple's version 1.3
(UCSD II.1), but it should work under previous versions.
The disk image
contains the file ZAP.TEXT, the source for the
current version. The file ZAPA.TEXT is the assembly source, listed here. The file
ZAP0.TEXT is the source for an earlier, more portable version. I'd be interested
to hear if anyone moves it to another implementation of UCSD Pascal.
The
program is provided under the GNU Public License, a copy of which may be found
at gnu.org. You should read
the license before using zap, noting that there is NO WARRANTY OF ANY KIND.
Because here is NO LIABILITY FOR DAMAGES, never use zap on a disk volume for
which you do not have a current backup.
Zap: source
code.
{$R-, I-}
program Zap;
{Edit disk or memory}
{Copyright 1984, 2004 John B. Matthews; distribution per GPL}
const
bLength = 512; {Block length}
type
CrtCommand = (home, clrEOS, clrEOL, up, down, right, left, leadIn);
Modes = (ascii, hexad, memory);
Bytes = packed array [0 .. 255 ] of 0 .. 255;
Word = record case Integer of
0: (i: Integer);
1: (h: packed array [0 .. 3] of 0 .. 15);
2: (a: packed array [0 .. 1] of 0 .. 255);
3: (b: ^bytes)
end;
var
hexB: packed array[0 .. 1] of Char;
hexW: packed array[0 .. 3] of Char;
hex: packed array[0 .. 15] of Char;
buf: packed array[0 .. 511] of 0 .. 255;
line: packed array[0 .. 63] of Char;
crtInfo: packed array[CrtCommand] of Char;
prefixed: array[CrtCommand] of Boolean;
unitNum: Integer;
maxBlock: Integer;
block: Integer;
dPag,mPag: Integer;
mode: Modes;
command: Char;
procedure HexDump(var source; offset: Integer; var buffer); external;
procedure AscDump(var source; offset: Integer; var buffer); external;
procedure Crt(c: CrtCommand);
begin
if prefixed[c] then UnitWrite(1, crtInfo[LeadIn], 1, 0, 12);
UnitWrite(1, CrtInfo[c], 1, 0, 12)
end; {Crt}
{Convert lo byte of v to hex in hexB}
procedure HexByte(v: Integer);
var w: Word;
begin
with w do begin
i := v;
hexB[0] := hex[h[1]];
hexB[1] := hex[h[0]]
end
end; {HexByte}
{Convert unsigned 16 bit v to hex in hexW}
procedure HexWord(v: Integer);
var w: Word;
begin
with w do begin
i := v;
hexW[0] := hex[h[3]];
hexW[1] := hex[h[2]];
hexW[2] := hex[h[1]];
hexW[3] := hex[h[0]]
end
end; {HexWord}
{Return next decimal number in s; i points to next non-digit}
function IVal(var s: String; var i: Integer): Integer;
var v: Integer;
begin
v := 0;
while ((i <= Length(s)) and (Scan(10, =s[i], hex) = 10)) do i := Succ(i);
while ((i <= Length(s)) and (Scan(10, =s[i], hex) < 10)) do
begin
v := v * 10 + Scan(10, =s[i], hex);
i := Succ(i)
end;
Ival := v
end; {IVal}
{Return next hex number in s; i points to next non-digit}
function HVal(var s: String; var i: Integer): Integer;
var v: Integer;
begin
v := 0;
while ((i <= Length(s)) and (Scan(16, =s[i], hex) = 16)) do i := Succ(i);
while ((i <= Length(s)) and (Scan(16, =s[i], hex) < 16)) do
begin
v := v * 16 + Scan(16, =s[i], hex);
i := Succ(i)
end;
Hval := v
end; {HVal}
procedure UpperCase(var s: String);
var i: Integer;
begin
i := 1;
while i <= Length(s) do begin
if s[i] in ['a' .. 'z'] then
s[i] := Chr(Ord(s[i]) - 32);
i := Succ(i)
end
end; {UpperCase}
procedure ShowAscii;
const col = 32;
var index: Integer;
begin
GoToXY(0, 1); Crt(clrEOS); GoToXY(0, 3); index := 0;
repeat
Write(index:6, ': ');
AscDump(buf, index, line);
UnitWrite(1, line, col); WriteLn;
index := index + col;
until index = bLength;
end; {ShowAscii}
procedure ShowHex;
var index, linenumber: Integer;
begin
GoToXY(0, 1); Crt(clrEOS); GoToXY(0, 3);
index := 256 * dPag;
linenumber := 0;
repeat
linenumber := Succ(linenumber);
HexWord(index);
UnitWrite(1, hexW, 4);
Write(': ');
HexDump(buf, index, line);
UnitWrite(1, line, SizeOf(line));
Writeln;
index := index + 16;
until linenumber = 16;
end; {ShowHex}
procedure ShowMem;
var m: Word;
begin
GoToXY(0, 1); Crt(clrEOS); GoToXY(0, 3);
with m do begin
a[0] := 0; a[1] := mPag;
repeat
HexWord(i);
UnitWrite(1, hexW, 4);
Write(': ');
HexDump(b^, 0, line);
UnitWrite(1, line, SizeOf(line));
Writeln;
i := i + 16;
until a[0] = 0;
end
end; {ShowMem}
procedure Show;
begin
if mode = ascii then ShowAscii
else if mode = hexad then ShowHex
else ShowMem
end; {Show}
procedure EditAscii;
var i, p: Integer; s: String;
begin
Write('Edit: (:) '); ReadLn(s);
if Length(s) > 0 then begin
i := 1; p := IVal(s, i); i := Succ(i);
while ((i <= Length(s)) and (p < bLength)) do begin
buf[p] := Ord(s[i]);
p := Succ(p); i := Succ(i)
end;
ShowAscii
end
end; {EditAscii}
procedure EditHex;
var i, p: Integer; s:String;
begin
Write('Edit: (:) $'); ReadLn(s);
if Length(s) > 0 then begin
UpperCase(s);
i := 1; p := HVal(s, i); i := Succ(i);
while ((i <= Length(s)) and (p < bLength)) do begin
buf[p] := HVal(s, i);
p := Succ(p)
end;
ShowHex
end
end; {EditHex}
procedure EditMem;
var i :Integer; m: Word; s: String;
begin
Write('Edit: (:) $'); ReadLn(s);
if Length(s) > 0 then begin
UpperCase(s);
i := 1; m.i := HVal(s, i); i := Succ(i);
while i <= Length(s) do begin
m.b^[0] := HVal(s, i);
m.i := Succ(m.i)
end;
ShowMem
end
end; {EditMem}
procedure Edit;
begin
Crt(home); Crt(clrEOL);
if mode = ascii then EditAscii
else if mode = hexad then EditHex
else EditMem
end; {Edit}
procedure NextBlock;
begin
block := Succ(block);
if block >= maxBlock then block := 0
end; {NextBlock}
procedure PrevBlock;
begin
block := Pred(block);
if block < 0 then block := maxBlock - 1
end; {PrevBlock}
procedure FillBuffers;
var i: Integer;
begin
UnitRead(unitNum, buf, bLength, block);
if IOResult <> 0 then
FillChar(buf, SizeOf(buf), 255);
end; {FillBuffers}
procedure NextPage;
begin
if mode = ascii then
begin
Nextblock; FillBuffers; ShowAscii
end
else if mode = hexad then
begin
if dPag = 0 then dPag := 1
else
begin
NextBlock;
FillBuffers;
dPag := 0
end;
ShowHex
end
else
begin
mPag := Succ(mPag);
if mPag = 192 then mPag := 193; {skip C0xx}
ShowMem
end
end; {NextPage}
procedure PrevPage;
begin
if mode = ascii then
begin
Prevblock; FillBuffers; ShowAscii
end
else if mode = hexad then
begin
if dPag = 1 then dPag := 0
else
begin
PrevBlock;
FillBuffers;
dPag := 1
end;
ShowHex
end
else
begin
mPag := Pred(mPag);
if mPag = 192 then mPag := 191; {skip C0xx}
ShowMem
end
end; {PrevPage}
procedure RBlock;
var i: Integer; ch: char; s: String;
begin
Crt(Home); Crt(clrEOL);
Write('Block to read (, =N(ext, P(rev, S(ame): ');
Read(ch);
if EOLN then block := Succ(block);
case ch of
'N', 'n': NextBlock;
'P', 'p': PrevBlock;
'S', 's': block := block;
'0','1','2','3','4','5','6','7','8','9':
begin
ReadLn(s); i := 1;
s := Concat(' ', s);
s[1] := ch;
block := IVal(s, i)
end
end;
FillBuffers;
dPag := 0;
if mode = memory then mode := hexad;
Show
end; {RBlock}
procedure WBlock;
var ch: Char; i, blk: Integer; s: String;
begin
Crt(home); Crt(clrEOL); blk := block; i := 1;
Write('Block to write? =[', blk, '] '); ReadLn(s);
if Length(s) > 0 then blk := IVal(s, i);
Write('Write block number [', blk, '] OK? '); Read(ch);
if ch in ['Y', 'y'] then begin
UnitWrite(unitNum, buf, bLength, blk);
if IOResult = 0 then
WriteLn('...Block [', blk, '] written')
end
end; {WBlock}
procedure Whatpage;
var i: Integer; m: Word; s:String;
begin
Crt(Home); Crt(clrEOL);
Write('What page of memory: $');
ReadLn(s); UpperCase(s);
i := 1; mPag := HVal(s, i);
if mPag <> 192 then ShowMem else begin
repeat {Handle C0xx one byte at a time}
Crt(home); Crt(clrEOL);
Write('Examine what byte: ');
ReadLn(s);
if Length(s) > 0 then begin
UpperCase(s);
i := 1; m.i := HVal(s, i);
HexWord(m.i); HexByte(m.b^[0]);
Crt(clrEOL); write('$', hexW, ' = ', hexB)
end;
until length(s) = 0;
mPag := mPag - 1
end
end; {Whatpage}
procedure SelectDrive(ch: Char);
var volInfo: array[0 ..7] of Integer; s: String; i: Integer;
begin
case ch of
'0' : unitNum := 10;
'1' : unitNum := 11;
'2' : unitNum := 12;
'4' : unitNum := 4;
'5' : unitNum := 5;
'9' : unitNum := 9;
end;
UnitRead(unitNum, volInfo, SizeOf(volinfo), 2);
if IOResult = 0 then
if volInfo[2] = 0 then maxBlock := volInfo[7]
else begin
Crt(home); Crt(clrEOL);
Write('How many blocks on this volume? ');
ReadLn(s); i := 0;
maxBlock := Ival(s, i)
end
else maxBlock := 1
end; {SelectDrive}
procedure ListDirectory(unitNumber: Integer);
type
DateRec = packed record
Month: 0..12;
Day: 0..31;
Year: 0..100
end;
VolName = String[7];
FileName = String[15];
FileType = (volume, xDisk, code, text, info, data, graf, foto, secure);
DirEntry = record
dFirstBlk: Integer;
dLastBlk: Integer;
case dFileType: FileType of
volume, secure: (
dVName: VolName;
dBlkCount: Integer; {Blocks on this volume}
dRecCount: Integer; {Directory record count}
dZeroBlk: Integer; {Start block}
dLastBoot: DateRec);{Date formatted or booted}
xDisk, code, text, info, data, graf, foto: (
dFName: FileName;
dLastByte: 1 .. 512;
dAccess: DateRec)
end;
Directory = array[0 .. 77] of DirEntry;
var
i, blocks, count: Integer; dir: Directory;
procedure WriteDate(date: DateRec);
begin
with date do
begin
Write(day:2,'-');
case month of
1: Write('Jan');
2: Write('Feb');
3: Write('Mar');
4: Write('Apr');
5: Write('May');
6: Write('Jun');
7: Write('Jul');
8: Write('Aug');
9: Write('Sep');
10: Write('Oct');
11: Write('Nov');
12: Write('Dec');
end {case};
if year < 10 then Write('-0', year:1)
else Write('-', year:2)
end {with};
end; {WriteDate}
procedure WriteFileType(fType: FileType);
begin
case fType of
code: Write('Code file');
text: Write('Text file');
data: Write('Data file');
info: Write('Info file');
xDisk: Write('Bad block');
end {case};
end; {WriteFileType}
begin {ListDirectory}
UnitRead(unitNumber, dir[0], SizeOf(dir), 2);
if (IOResult = 0) and (dir[0].dFileType = volume) then
begin with dir[0] do
begin
Write('Unit #', unitNumber, ' is ',
dVName, ': ', dBlkCount, ' blocks dated ');
WriteDate(dLastBoot);
WriteLn;
Count := DRecCount;
end;
for i := 1 to Count do begin
with dir[i] do begin
blocks := dLastBlk - dFirstBlk;
Write(dFName, ' ':18 - Length(dFName),
dFirstBlk:4, ' ', blocks:4, ' ');
WriteDate(dAccess);
Write(' ');
WriteFileType(dFileType);
WriteLn;
end {with}
end {for}
end {if}
else
WriteLn('Unit #', unitNumber, ' is off line or has no directory');
end; {ListDirectory}
procedure GetCRTInfo;
var buffer: packed array[0..511] of Char;
i, byte: Integer; f: File;
begin
reset(f,'*SYSTEM.MISCINFO');
i := BlockRead(f, buffer, 1);
Close(f);
byte := Ord(buffer[72]); {Prefix array}
crtInfo[leadIn] := buffer[62]; prefixed[leadIn] := False;
crtInfo[home] := buffer[63]; prefixed[home] := Odd(byte DIV 16);
crtInfo[clrEOS] := buffer[64]; prefixed[clrEOS] := Odd(byte DIV 8);
crtInfo[clrEOL] := buffer[65]; prefixed[clrEOL] := Odd(byte DIV 4);
crtInfo[right] := buffer[66]; prefixed[right] := Odd(byte DIV 2);
crtInfo[up] := buffer[67]; prefixed[up] := Odd(byte);
crtInfo[left] := buffer[68]; prefixed[left] := Odd(byte DIV 32);
crtInfo[down] := Chr(10); prefixed[down] := False;
end; {GetCRTInfo}
procedure Help;
begin
Crt(home); Crt(clrEOS);
WriteLn; WriteLn;
WriteLn('Zap is a disk and memory editor. In disk mode, it shows the current disk');
WriteLn('drive unit number followed by the current decimal block number in brackets.');
WriteLn('In memory mode, it shows the current page number in hexadecimal.');
WriteLn('Command Summary:');
WriteLn('R: Read a 512 byte disk block from the current drive.');
WriteLn('W: Write the current 512 byte block to the current drive.');
WriteLn('E: Edit the current block in hex or Ascii; edit memory in hex.');
WriteLn(' Ascii mode uses decimal offsets -> 95:Klingons!');
WriteLn(' Hex mode does not -> 5f:4B 6C 69 6E 67 6F 6E 73 21.');
WriteLn('A: Display the current 512 byte block as Ascii text.');
WriteLn('H: Display 256 bytes of the current block as hex and Ascii.');
WriteLn('M: Display a page of memory in hex and Ascii');
WriteLn(' Zap will not display page C0. If you specify page C0, you can enter a');
WriteLn(' single address, e.g. C050/1 to toggle the graphics/text display.');
WriteLn('P: Toggle between pages of a disk block, or select a memory page.');
WriteLn('D: List the directory of a Pascal disk in the current disk drive.');
WriteLn('Q: Quit to the system.');
WriteLn('?: Display help.');
WriteLn('+: Advance to the next page of disk or memory.');
WriteLn('-: Return to the previous page of disk or memory.');
WriteLn('4, 5, 9, 0, 1, 2: Switch to units 4, 5 ,9, 10, 11 or 12, respectively.')
end;
begin {main}
Page(Output);
Write('Zap @1984, 2004 John B. Matthews, Initializing...');
GetCRTInfo;
hex := '0123456789ABCDEF';
SelectDrive('4'); block := 2; dPag := 0; mPag := 0;
mode := hexad; FillBuffers; Show;
repeat
Crt(home); Crt(clrEOL); Write('Zap #', unitNum, ' [');
if mode <> memory then Write(block)
else begin HexByte(mPag); Write('$', hexB) end;
Write(']: R(ead, W(rite, E(dit, A(sc, H(ex, M(em, P(ag, D(ir, Q(uit, ? ');
Read(KeyBoard, command);
if EOLN(KeyBoard) then RBlock else
case command of
'R', 'r': RBlock;
'W', 'w': WBlock;
'E', 'e': Edit;
'A', 'a': begin mode := ascii; Show end;
'H', 'h': begin mode := hexad; Show end;
'M', 'm': begin mode := memory; Show end;
'P', 'p':
begin
if mode = hexad then begin
if dPag = 0 then dPag := 1 else dPag := 0;
ShowHex
end
else if mode = memory then WhatPage
end;
'D', 'd':
begin
Crt(home); Crt(clrEOS); GoToXY(0, 1);
ListDirectory(unitNum)
end;
'-', '_': PrevPage;
'=', '+': NextPage;
'?', '/': Help;
' ' : Crt(clrEOS);
'0','1','2','4','5','9' : SelectDrive(command);
end {case}
until command in ['Q', 'q'];
WriteLn; WriteLn('That''s all folks...');
end.
Zap: assembly listing.
0000| ;HexDump(var source; offset: Integer; var buffer);
0000| ;Convert 16 bytes at source + offset to hex and Ascii;
0000| ;store in buffer; buffer must be at least 64 bytes.
0000|
0000| ;AscDump(var source; offset: Integer; var buffer);
0000| ;Convert 32 bytes at source + offset to Ascii;
0000| ;store in buffer; buffer must be at least 32 bytes.
0000|
0000| .macro pop
0000| pla
0000| sta %1
0000| pla
0000| sta %1+1
0000| .endm
0000|
0000| .macro psh
0000| lda %1+1
0000| pha
0000| lda %1
0000| pha
0000| .endm
0000|
0000| 0000 return .equ 0
0000| 0002 buffer .equ return+2
0000| 0004 offset .equ buffer+2
0000| 0006 source .equ offset+2
0000|
0000| .proc hexdump,3
0000| pop return
0000| 68 # PLA
0001| 85 00 # STA return
0003| 68 # PLA
0004| 85 01 # STA return+1
0006| pop buffer
0006| 68 # PLA
0007| 85 02 # STA buffer
0009| 68 # PLA
000A| 85 03 # STA buffer+1
000C| pop offset
000C| 68 # PLA
000D| 85 04 # STA offset
000F| 68 # PLA
0010| 85 05 # STA offset+1
0012| pop source
0012| 68 # PLA
0013| 85 06 # STA source
0015| 68 # PLA
0016| 85 07 # STA source+1
0018| 18 clc
0019| A5 06 lda source
001B| 65 04 adc offset
001D| 85 06 sta source
001F| A5 07 lda source+1
0021| 65 05 adc offset+1
0023| 85 07 sta source+1
0025| A2 00 ldx #0
0027| 8A hexloop txa
0028| A8 tay
0029| B1 06 lda @source,y
002B| 48 pha
002C| 4A lsr a
002D| 4A lsr a
002E| 4A lsr a
002F| 4A lsr a
0030| 20 **** jsr dohex
0033| 68 pla
0034| 20 **** jsr dohex
0037| A9 20 lda #20
0039| 20 **** jsr store
003C| E8 inx
003D| E0 10 cpx #10
003F| 90E6 bcc hexloop
0041| A0 00 ldy #0
0043| B1 06 ascloop lda @source,y
0045| 29 7F and #7f
0047| C9 20 cmp #20
0049| B0** bcs $1
004B| A9 2E lda #2e
0049* 02
004D| 91 02 $1 sta @buffer,y
004F| C8 iny
0050| C0 10 cpy #10
0052| 90EF bcc ascloop
0054| psh return
0054| A5 01 # LDA return+1
0056| 48 # PHA
0057| A5 00 # LDA return
0059| 48 # PHA
005A| 60 rts
005B|
005B| ;convert lo nibble in A to hex
0035* 5B00
0031* 5B00
005B| 29 0F dohex and #0f
005D| 09 30 ora #30
005F| C9 3A cmp #3a
0061| 90** bcc store
0063| 69 06 adc #06
0065| ;store A in buffer; increment buffer; zeroes Y
0061* 02
003A* 6500
0065| A0 00 store ldy #0
0067| 91 02 sta @buffer,y
0069| E6 02 inc buffer
006B| D0** bne $1
006D| E6 03 inc buffer+1
006B* 02
006F| 60 $1 rts
0070|
0000| .proc ascdump,3
0000| pop return
0000| 68 # PLA
0001| 85 00 # STA return
0003| 68 # PLA
0004| 85 01 # STA return+1
0006| pop buffer
0006| 68 # PLA
0007| 85 02 # STA buffer
0009| 68 # PLA
000A| 85 03 # STA buffer+1
000C| pop offset
000C| 68 # PLA
000D| 85 04 # STA offset
000F| 68 # PLA
0010| 85 05 # STA offset+1
0012| pop source
0012| 68 # PLA
0013| 85 06 # STA source
0015| 68 # PLA
0016| 85 07 # STA source+1
0018| 18 clc
0019| A5 06 lda source
001B| 65 04 adc offset
001D| 85 06 sta source
001F| A5 07 lda source+1
0021| 65 05 adc offset+1
0023| 85 07 sta source+1
0025| A0 00 ldy #0
0027| B1 06 ascloop lda @source,y
0029| 29 7F and #7f
002B| C9 20 cmp #20
002D| B0** bcs $1
002F| A9 2E lda #2e
002D* 02
0031| 91 02 $1 sta @buffer,y
0033| C8 iny
0034| C0 20 cpy #20
0036| 90EF bcc ascloop
0038| psh return
0038| A5 01 # LDA return+1
003A| 48 # PHA
003B| A5 00 # LDA return
003D| 48 # PHA
003E| 60 rts
003F|
003F| .end
Copyright 1984, 2004 John B. Matthews
Distribution permitted under the
terms of the GPL: http://www.gnu.org/copyleft/gpl.html.
Last updated
30-Aug-2004
Return
home.